perm filename UTIL4[AM,DBL] blob sn#183510 filedate 1975-10-24 generic text, type T, neo UTF8
(FILECREATED "24-OCT-75 03:25:21" <LENAT>UTIL4.;34 19202  

     changes to:  FIXEDCONS GLOBALVARS SAVECOMS

     previous date: "22-OCT-75 03:32:51" <LENAT>UTIL4.;32)


  (LISPXPRINT (QUOTE UTIL4COMS)
	      T T)
  [RPAQQ UTIL4COMS
	 ((FNS ACCEPT-B AM-BT CHANGE-B CLEAN CLEAN1 CLEANALL CONDENSEB ED-1F ED-1P ED-1V ED-ALL ED-ALLF ED-ALLP ED-ALLV 
	       FORGOT-ANY GLOB INIT-MAC INIT2 KILLB LISTF LISTFILES1 MAPB MAPP MCON MFIX MTOP NEW-VERSION NFACET NFUN 
	       RESET1 RESET2 RESET3 RESTORE-EXPR SAVE SHOWP SUPERTRACE TRANFUN UPCASE XEQ-CLEAN)
	  BB FIXCOMS FIXEDCONS GLOBALVARS REPR-FNS SAVECOMS STICKY-B STICKY-P SYS-FORGET-LIST UCASELST VERSION
	  (USERMACROS C COPY)
	  (P (INIT-MAC))
	  (P (SETQ FIXEDCONS NIL))
	  (P (SETQ FIXVARS NIL))
	  (P (SETQ FIXFNS NIL))
	  [P (ADVISE (QUOTE EDITV)
		     (QUOTE (SETQ FIXVARS (UNION EDITVX FIXVARS]
	  [P (ADVISE (QUOTE EDITF)
		     (QUOTE (SETQ FIXFNS (UNION EDITFX FIXFNS]
	  [P (ADVISE (QUOTE DEFINEQ)
		     (QUOTE (SETQ FIXFNS (UNION (LIST (CAAR X))
						FIXFNS]
	  (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
										(NLAML MTOP MAPP MAPB]
(DEFINEQ

(ACCEPT-B
  [LAMBDA (B SIM)
    (CREATEB B)
    (TERPRI)
    [COND
      ((FMEMB SIM CONCEPTS))
      ((PRIN1 "NAME OF SIMILAR BEING... ")
	(SETQ SIM (RATOM]
    (TERPRI)
    (SET B (COPY (GETTOPVAL SIM)))
    (SETPROPLIST B (COPY (GETPROPLIST SIM)))
    (ERRORSET (LIST (QUOTE EDITV)
		    B
		    (LIST (QUOTE RC)
			  SIM B)))
    (ERRORSET (LIST (QUOTE EDITV)
		    B))
    (ERRORSET (LIST (QUOTE EDITP)
		    B
		    (LIST (QUOTE RC)
			  SIM B)))
    (ERRORSET (LIST (QUOTE EDITP)
		    B))
    (DEFB B)
    (PRIN1 "THE NUMBER OF CONCEPTS IS NOW ")
    (PRINT (LENGTH CONCEPTS))
    B])

(AM-BT
  [LAMBDA (V1)
    (MAPDL (FUNCTION (LAMBDA (DX)
	       (COND
		 ((OR (FMEMB DX (CAR TOP4COMS))
		      (FMEMB DX (CAR UTIL4COMS))
		      (FMEMB DX CONCEPTS))
		   (PRIN1 DX)
		   (COND
		     ((SETQ V1 (VARIABLES MAPDLPOS))
		       (TERPRI)
		       (PRIN1 "   ")
		       (PRINT V1)
		       (PRIN1 "   ")
		       (PRINT (STKARGS MAPDLPOS)))
		     ((PRIN1 "  ---NO ARGS")
		       (TERPRI])

(CHANGE-B
  [LAMBDA (B P CP)
    [COND
      ((OR (FMEMB B FACETS)
	   (FMEMB B AUX-FACETS))
	(SETQ P B)
	(PRINT (SETQ B STICKY-B)))
      [(GETHASH B HCON)
	(OR (FMEMB P FACETS)
	    (FMEMB P AUX-FACETS)
	    (PRINT (SETQ P STICKY-P]
      (B (TERPRI)
	 (PRIN1 "***** CANT UNDERSTAND THIS *****")
	 (HELP))
      (T (PRINT (SETQ B STICKY-B))
	 (PRINT (SETQ P STICKY-P]
    (SETQ STICKY-B B)
    (SETQ STICKY-P P)
    (OR (GETB B P)
	(INIT-PART B P))
    (ERRORSET (LIST (QUOTE EDITP)
		    B
		    (QUOTE F)
		    P
		    (QUOTE P)
		    (QUOTE TTY:)))
    (DEFB B)
    (TERPRI)
    (PRIN1 B)
    (PRIN1 COMMA)
    (PRINT P)
    (SETQ FIXEDCONS (UNION (LIST B)
			   FIXEDCONS])

(CLEAN
  [LAMBDA (P1 P2 P1I P2I)
    (SETQ P2I (GETB (GLUE (QUOTE ANYB)
			  P2)
		    (QUOTE INIT)))
    (MAPC CONCEPTS (FUNCTION (LAMBDA (C)
	      (MAPC (GETB C P1)
		    (FUNCTION (LAMBDA (B)
			(AND (IS-CON B)
			     (PUT B P2 (APPEND P2I (UNION (LIST C)
							  (GETB B P2])

(CLEAN1
  [LAMBDA (B P1 P2)
    (MAPC (GETB B P1)
	  (FUNCTION (LAMBDA (Z)
	      (AND (IS-CON Z)
		   (INCRB Z P2 B])

(CLEANALL
  [LAMBDA NIL
    (CLEAN (QUOTE SPEC)
	   (QUOTE GENL))
    (CLEAN (QUOTE GENL)
	   (QUOTE SPEC))
    (CLEAN (QUOTE UP)
	   (QUOTE EXS])

(CONDENSEB
  [LAMBDA (CONFILE)
    (SETQ DFNFLG NIL)
    (MAPC NEW-PARTS (QUOTE RESTORE-EXPR))
    (SETQ VERSION (ADD1 VERSION))
    (SETQ CONFILE (PACK (LIST (QUOTE CON)
			      VERSION)))
    (SET (PACK (LIST CONFILE (QUOTE COMS)))
	 (CONS (CONS (QUOTE FNS)
		     NEW-PARTS)
	       NEW-CONCEPTS))
    (MAKEFILE CONFILE (QUOTE C))
    (NCONC (DREMOVE (QUOTE DUMMY)
		    NEW-CONCEPTS)
	   CONCEPTS)
    (SETQ NEW-CONCEPTS (LIST (QUOTE DUMMY)))
    (SETQ NEW-PARTS NIL)
    (SETQ NEW-C-PARTS NIL])

(ED-1F
  [LAMBDA (F1)
    (AND (ERRORSET (CONS (QUOTE EDITF)
			 (CONS F1 ECMS)))
	 (PRIN1 F1)
	 (PRIN1 "  "])

(ED-1P
  [LAMBDA (P1)
    (AND (CDR P1)
	 (ERRORSET (CONS (QUOTE EDITP)
			 (CONS P1 ECMS)))
	 (PRIN1 P1)
	 (PRIN1 "  "])

(ED-1V
  [LAMBDA (V1)
    (AND (LITATOM V1)
	 (OR (NEQ (QUOTE NOBIND)
		  (GETTOPVAL V1))
	     (CPRIN1 2 " WARNING: THE VARIABLE " V1 " IS UNBOUND. " CRLF))
	 (ERRORSET (CONS (QUOTE EDITV)
			 (CONS V1 ECMS)))
	 (PRIN1 V1)
	 (PRIN1 "  "])

(ED-ALL
  [LAMBDA (EECMS)
    (SETQ ECMS EECMS)
    (ED-ALLF)
    (ED-ALLV)
    (ED-ALLP])

(ED-ALLF
  [LAMBDA NIL
    (MAPC (CDAR TOP4COMS)
	  (QUOTE ED-1F))
    (MAPC CONCEPTS (QUOTE ED-1F))
    (MAPC FACETS (QUOTE ED-1F))
    (MAPC (CDADR TOP4COMS)
	  (QUOTE ED-1F))
    (MAPC (CDAR CON4COMS)
	  (QUOTE ED-1F))
    (MAPC (CDAR UTIL4COMS)
	  (QUOTE ED-1F])

(ED-ALLP
  [LAMBDA NIL
    (MAPC CONCEPTS (QUOTE ED-1P])

(ED-ALLV
  [LAMBDA NIL
    (MAPC TOP4COMS (QUOTE ED-1V))
    (MAPC CON4COMS (QUOTE ED-1V))
    (MAPC UTIL4COMS (QUOTE ED-1V))
    (MAPC CONCEPTS (QUOTE ED-1V))
    (MAPC FACETS (QUOTE ED-1V])

(FORGOT-ANY
  [LAMBDA (FF)
    (TERPRI)
    (PRIN1 "MAYBE YOU FORGOT SOME OF THESE: ")
    [MAPATOMS (FUNCTION (LAMBDA (X)
		  (AND (EXPRP X)
		       (NOT (MEMB X (CAR TOP4COMS)))
		       (NOT (MEMB X (CADR TOP4COMS)))
		       (NOT (MEMB X (CAR UTIL4COMS)))
		       (NOT (MEMB X CONCEPTS))
		       (NOT (MEMB X SYS-FORGET-LIST))
		       (NOT (MEMB X FACETS))
		       [NOT (MATCH (UNPACK X) WITH (X1←--@[LAMBDA (Z)
						       (GETHASH Z HCON]
						     '- X2←--@(LAMBDA (Z)
						       (MEMB Z FACETS]
		       (NOT (MEMB X (CAR CON4COMS)))
		       (NOT (MATCH (UNPACK X) WITH (-- '- 'E '- --)))
		       (NOT (MATCH (UNPACK X) WITH (-- 'B &@NUMBERP &@NUMBERP &@NUMBERP &@NUMBERP)))
		       (PRIN1 X)
		       (PRIN1 (QUOTE % % ))
		       (SETQ FF T]
    (COND
      (FF (TERPRI)
	  (PRINT (QUOTE THINK!!!)))
      (T (PRIN1 "  NEVER MIND. ")))
    (TERPRI])

(GLOB
  [LAMBDA (GV)
    [COND
      ((AND GV (NLISTP GV))
	(SETQ GV (LIST GV]
    (MERGE (SORT GV)
	   GLOBALVARS)
    (SETQ GLOBALVARS (INTERSECTION GLOBALVARS GLOBALVARS))
    (PRIN1 " THE NUMBER OF GLOBAL VARAIABLES IS NOW ")
    (PRINT (LENGTH GLOBALVARS])

(INIT-MAC
  [LAMBDA NIL
    (DEFLIST [QUOTE ((FGETB ((B P)
			     (GETP B P)))
		     [GETB (X (COND
				[(AND (LISTP (CADR X))
				      (EQ (CAADR X)
					  (QUOTE QUOTE)))
				  (COND
				    ((GETP (CADADR X)
					   (QUOTE UNDO-INIT))
				      (LIST (GETP (CADADR X)
						  (QUOTE UNDO-INIT))
					    (CONS (QUOTE GETP)
						  X)))
				    (T (CONS (QUOTE GETP)
					     X]
				(T (LIST (QUOTE APPLY*)
					 (LIST (QUOTE GETP)
					       (LIST (QUOTE SETQ)
						     (QUOTE PMAC)
						     (CADR X))
					       (LIST (QUOTE QUOTE)
						     (QUOTE UNDO-INIT)))
					 (LIST (QUOTE GETP)
					       (CAR X)
					       (QUOTE PMAC]
		     (ACCESS ((X)
			      X))
		     (GETBQ ((B P)
			     (GETB (QUOTE B)
				   P)))
		     (SETBQ ((B P Q)
			     (PUT (QUOTE B)
				  (QUOTE P)
				  Q)))
		     (UNDO-INIT ((P L)
				 (APPLY* (GETP P (QUOTE UNDO-INIT))
					 L)))
		     [APPLYB (X (COND
				  ((AND (LISTP (CAR X))
					(EQ (CAAR X)
					    (QUOTE QUOTE)))
				    (CONS (CADAR X)
					  (CDR X)))
				  (T (CONS (QUOTE APPLY*)
					   X]
		     (CSINT ((X)
			     (CAAR X)))
		     (CSOTHERS ((X)
				(CDR X)))
		     (CSBEST ((X)
			      (CAR X)))
		     (CINT ((X)
			    (CAR X)))
		     (RPLACINT ((X Y)
				(RPLACA X Y)))
		     (PINT ((X)
			    (CAR X)))
		     (P-OP ((X)
			    (CADR X)))
		     (P-B ((X)
			   (CADDR X)))
		     (P-P ((X)
			   (CADDDR X)))
		     (COP ((X)
			   (CADR X)))
		     (CB ((X)
			  (CADDR X)))
		     (CP ((X)
			  (CADDDR X)))
		     (CACT ((X)
			    (CDR X)))
		     [BPFS ((X)
			    (CDDR (CADDR (GETD X]
		     (IPRED ((X)
			     (CAR X)))
		     (IDEF ((X)
			    (CADR X)))
		     (IVAL ((X)
			    (CADDR X)))
		     (IFEATURES ((X)
				 (CDDR X)))
		     (IMAT ((X)
			    (CDADR X)))
		     (IFEA ((X)
			    (CADR X)))
		     [TYPE (X (CAR (LAST X]
		     (ANY-OF (X (CONS (QUOTE OR)
				      X)))
		     (ANY1OF ((X)
			      (CAR X)))
		     [ANY1OF (X (PROGN                                          (* RAND-MEMB X)
				       (CAR X]
		     (ALL-OF (X (CONS (QUOTE APPEND)
				      X)))
		     (Q ((X)
			 (QUOTE (QUOTE X]
	     (QUOTE MACRO])

(INIT2
  [LAMBDA NIL
    (SETQ DFNFLG T)
    (SETQ LISPXHISTORY)
    (SETQ EDITHISTORY])

(KILLB
  [LAMBDA (B)
    (PUTD B NIL)
    (PUTHASH B NIL HCON)
    (DREMOVE B CONCEPTS)
    (DREMOVE B FIXEDCONS)                                                       (* Really, we should follow up links 
										like GENL from B, and destroy all 
										mention of it anywhere)
    (RPLACD B NIL])

(LISTF
  [LAMBDA NIL
    (TENEX "FTP
SAIL
LOG AM,DBL MER
SEND TOP4≠
TOP4
SEND CON4≠
CON4
SEND UTIL4≠
UTIL4
QUIT
"])

(LISTFILES1
  [LAMBDA (X)
    [COND
      ((NULL X)
	(TERPRI)
	(PRIN1 "NO MORE FILES TO LIST JUST NOW ")
	(TERPRI))
      ((LISTP X)
	(SETQ X (CAR X]
    (TERPRI)
    (SETQ X (UNPACK X))
    [AND (EQ (CAR X)
	     (QUOTE <))
	 (SETQ X (CDR (FMEMB (QUOTE >)
			     X]
    [SETQ X (PACK (LDIFF X (MEMB (QUOTE ;)
				 X]
    (TERPRI)
    (PRIN1 (CONCAT "SHOULD I FTP THE FILE " X " OVER TO SAIL? (Y,N)..."))
    (COND
      ((EQ (RATOM)
	   (QUOTE Y))
	(TENEX (CONCAT "FTP
SAIL
LOG AM,DBL MER
SEND " X "≠
" X "
QUIT
"])

(MAPB
  [NLAMBDA (F)
    (MAPC CONCEPTS (LIST (QUOTE LAMBDA)
			 (LIST (QUOTE B))
			 F])

(MAPP
  [NLAMBDA (F)
    (MAPC FACETS (LIST (QUOTE LAMBDA)
		       (LIST (QUOTE P))
		       F])

(MCON
  [LAMBDA NIL
    (SETQ CONCEPTS (SORT (COPY CONCEPTS)))
    (FORGOT-ANY)
    (MAKEFILE (QUOTE CON4)
	      (QUOTE RC])

(MFIX
  [LAMBDA NIL
    (SETQ FIXFNS (SUBSET FIXFNS (QUOTE EXPRP)))
    (SETQ FIXEDCONS (SUBSET FIXEDCONS (QUOTE IS-CON)))
    (SETQ FIXVARS (SUBSET FIXVARS (QUOTE ATOM)))
    (MAKEFILE (QUOTE FIX])

(MTOP
  [NLAMBDA (X)
    [RPLACA TOP4COMS (CONS (QUOTE FNS)
			   (MERGE X (CDAR TOP4COMS]
    (FORGOT-ANY)
    (MAKEFILE (QUOTE TOP4)
	      (QUOTE RC])

(NEW-VERSION
  [LAMBDA (NAME VNEW V OLD NEW)
    [COND
      (V)
      ((PROG1 (SETQ V VERSION)
	      (SETQ VERSION (ADD1 VERSION]
    (SETQ OLD (PACK (LIST NAME V)))
    [SETQ NEW (PACK (LIST NAME (OR VNEW (ADD1 V]
    [NLSETQ (SET (PACK (LIST NEW (QUOTE COMS)))
		 (EVAL (PACK (LIST OLD (QUOTE COMS]
    (PRIN1 (CONCAT "OLD: " OLD ", NEW: " NEW ", V:" V ", ECMS: " (QUOTE REPLACEMENT)))
    (ED-ALL (LIST (QUOTE RC) OLD NEW])

(NFACET
  [LAMBDA (F XEQ-FLAG SUF-FLAG)
    [COND
      ((ATOM F)
	(SETQ F (LIST F]
    [MAPC F (FUNCTION (LAMBDA (F1)
	      (PUT F1 (QUOTE ARGS)
		   (LIST (QUOTE BA1)
			 (QUOTE BA2)
			 (QUOTE BA3)
			 (QUOTE BA4)))
	      (PUT F1 (QUOTE UNDO-INIT)
		   (QUOTE ACCESS))
	      (COND
		(XEQ-FLAG (ATTACH F1 XEQ-PARTS)
			  (ATTACH F1 XS-PARTS)))
	      (COND
		(SUF-FLAG (ATTACH F1 SUF-PARTS)))
	      (DEFP F1)
	      (SETQ GTEMP1 (GLUE (QUOTE ANYB)
				 F1))
	      (COND
		((NOT (GETHASH GTEMP1 HCON))
		  (CREATEB GTEMP1)
		  (SET GTEMP1 NIL)
		  (PUTU GTEMP1 (QUOTE FROM-FILE)
			(QUOTE CON4))
		  (SETB GTEMP1 (QUOTE GENL)
			(LIST (QUOTE ANYB-ANYP]
    (SETQ FACETS (SORT (UNION F FACETS)))
    (PRIN1 "  THE NUMBER OF FACETS IS NOW ")
    (PRINT (LENGTH FACETS])

(NFUN
  [LAMBDA (FUNC FIL)
    (SETQ FIXFNS (UNION FUNC FIXFNS))
    [COND
      ((NULL FIL)
	(SETQ FIL (QUOTE TOP4]
    [SETQ FIL (PACK (LIST FIL (QUOTE COMS]
    [RPLACA (EVAL FIL)
	    (CONS (QUOTE FNS)
		  (SORT (UNION FUNC (CDAR (EVAL FIL]
    (CPRIN1 0 "Now " (LENGTH (CAR (EVAL FIL)))
	    " Functions on " FIL CRLF)
    (CLOCK 2])

(RESET1
  [LAMBDA NIL
    [MAPB (OR (EQ B (QUOTE LIST-STRUC))
	      (PROGN (REMPROP B (QUOTE EXS))
		     (REMPROP B (QUOTE EXS-BDY))
		     (REMPROP B (QUOTE INST]
    (UNBREAK)
    (BREAKDOWN)
    (MAPC CONCEPTS (QUOTE BREAKDOWN))
    (MAPC (CDAR TOP4COMS)
	  (QUOTE BREAKDOWN))
    (CLOCK 2])

(RESET2
  [LAMBDA NIL
    (MAPB (OR (EQ B (QUOTE LIST-STRUC))
	      (PROGN (REMPROP B (QUOTE EXS))
		     (REMPROP B (QUOTE EXS-BDY])

(RESET3
  [LAMBDA NIL
    [SETQ VCONCEPTS (SUBSET CONCEPTS (FUNCTION (LAMBDA (C)
				(NEQ (GETTOPVAL C)
				     (QUOTE NOBIND]
    (SETQ NCONCEPTS (SET-DIFF CONCEPTS VCONCEPTS))
    [MAPC VCONCEPTS (FUNCTION (LAMBDA (B)
	      [OR (EQ B (QUOTE LIST-STRUC))
		  (PROGN (REMPROP B (QUOTE EXS-NOT))
			 (REMPROP B (QUOTE EXS))
			 (REMPROP B (QUOTE EXS-NOT-BDY))
			 (REMPROP B (QUOTE EXS-BDY]
	      [MAPP (COND
		      [(LISTP (GETB B P))
			(SETB B P (SUBSET (GETP B P)
					  (FUNCTION (LAMBDA (X)
					      (COND
						((FMEMB X VCONCEPTS)
						  T)
						((MEMB X NCONCEPTS)
						  NIL)
						((NLISTP X)
						  T)
						([EVERY (FLATTEN X)
							(FUNCTION (LAMBDA (XX)
							    (NOT (MEMB XX NCONCEPTS]
						  T)
						(T NIL]
		      ((NULL (GETB B P))
			(REMPROP B P]
	      (CLEAN1 B (QUOTE UP)
		      (QUOTE EXS))
	      (CLEAN1 B (QUOTE GENL)
		      (QUOTE SPEC))
	      (CLEAN1 B (QUOTE SPEC)
		      (QUOTE GENL]
    (SETQ CONCEPTS VCONCEPTS)
    (CPRIN1 0 CRLF " About to call INIT-C. " (LENGTH NCONCEPTS)
	    " were expunged." CRLF)
    (INIT-C])

(RESTORE-EXPR
  [LAMBDA (BPNAME)
    (UNSAVEDEF BPNAME (QUOTE EXPR])

(SAVE
  [LAMBDA NIL
    (MAKEFILE (QUOTE SAVE])

(SHOWP
  [LAMBDA (P)
    (SETQ GTEMP6 NIL)
    (MAPB (AND (GETB B P)
	       (PRINT B)
	       (PRINT (GETB B P))
	       (SETQ GTEMP6 (NCONC1 GTEMP6 B))
	       (TERPRI)))
    (PRIN1 " GTEMP6 = ")
    GTEMP6])

(SUPERTRACE
  [LAMBDA (X Z)
    (COND
      ((NLISTP X)
	(CPRIN1 0 X " is " (SETQ Z (EVAL X))
		CRLF)
	Z)
      ((MEMB (ARGTYPE (CAR X))
	     (LIST 1 3))
	(CPRIN1 0 " NL-Function call " X CRLF)
	(CPRIN1 0 " Return value of " (CAR X)
		" is "
		(SETQ Z (EVAL X))
		CRLF)
	Z)
      ((MEMB (ARGTYPE (CAR X))
	     (LIST 0 2))
	(CPRIN1 0 " Function call " X CRLF)
	(SETQ Z (MAPCAR (CDR X)
			(QUOTE SUPERTRACE)))
	(CPRIN1 0 " Return value of " (CAR X)
		" is "
		(SETQ Z (APPLY (CAR X)
			       Z))
		CRLF)
	Z])

(TRANFUN
  [LAMBDA (F FIL1 FIL2 F1COMS F2COMS)
    [COND
      ((ATOM F)
	(SETQ F (LIST F]
    [SETQ F1COMS (PACK (LIST FIL1 (QUOTE COMS]
    [SETQ F2COMS (PACK (LIST FIL2 (QUOTE COMS]
    [COND
      ((NLISTP (CAR F2COMS))
	(PRIN1 " INITIALIZATION IS REQUIRED ")
	(TERPRI)
	(SET F2COMS (CONS (LIST (QUOTE FNS)
				(QUOTE DUMMY))
			  (COPY (CDR (EVAL F1COMS]
    (COND
      ((NLISTP (CAR F1COMS))
	(HELP "FIRST FILE'S COMS IS NULL ")))
    (SETQ F (SORT F))
    (MERGE (COPY F)
	   (CDAR (EVAL F2COMS)))
    (DREMOVE (QUOTE DUMMY)
	     (CAR (EVAL F2COMS)))
    (MAPC F (FUNCTION (LAMBDA (F1)
	      (DREMOVE F1 (CAR (EVAL F1COMS])

(UPCASE
  [LAMBDA NIL
    (SETQ UCASELST (NCONC (SUBSET TOP4COMS (QUOTE ATOM))
			  (SUBSET CON4COMS (QUOTE ATOM])

(XEQ-CLEAN
  [LAMBDA (B B1 B2 B3)
    (MATCH (DREVERSE (UNPACK B)) WITH (B2←$
					(QUOTE -)
					B1←$))
    (SETQ B1 (PACK (DREVERSE B1)))
    (SETQ B2 (PACK (DREVERSE B2)))
    (AND (FMEMB B2 FACETS)
	 (GETHASH B1 HCON)
	 NIL)                                                                   (* NOTNEEDED APPARENTLY.
										PERHAPS: in the function CREATEB)
    ])
)
  (RPAQQ BB
	 (SET-STRUC-DELETE-E-INV STRUCTURE-MEMB STRUCTURE-INSERT RAND-MEMB SET-STRUC-DELETE OSET-STRUC INSTAN-PAT 
				 INSTAN-REC INSTAN-BASE INSTAN-S INSTAN-D INSTAN-I INSTAN-1D INSTAN-1I INSTAN-1S 
				 PICK-CAND XEQ-CAND UPDATE TLOOP GENL FILLIN PXEQ PGET APPLYB-P GETB-P-C RIPPLE-SIMULT 
				 PSUF EXS RAND-THING))
  [RPAQQ FIXCOMS ((FNS * FIXFNS)
	  [VARS * (SETQ FIXVARS (SUBSET FIXVARS (QUOTE ATOM]
	  CONCEPTS FIXEDCONS FIXFNS FIXVARS (COMS * (LIST (CONS (QUOTE IFPROP)
								(CONS (QUOTE ALL)
								      FIXEDCONS]
  (RPAQQ FIXEDCONS (ACTIVE-EXS-NOT-BDY ACTIVE-EXS INTERESTING-SET-STRUC STRUCTURE))
  (RPAQQ GLOBALVARS
	 (ACEX-OLDB ACEX-OLDV ACEXPIRE ALLOP ARGS AUX-FACETS B-DEF BA-LIST BAL1 BAL2 CAND CAND-TAIL CANDS CIRC COMMA 
		    CON4COMS CONCEPTS CONSTRUCTIVE-OPS CRLF CS-ACT CS-B CS-FAIL CS-INT CS-OP CS-P CVAL DO-THRESH ECMS 
		    EX-THRESH EXTHRESH F-COUNTER FACETS FROB FROB1 G-IF GATH-PART GCNT GEXISTING GIFN GLEN GNUMS GPGM 
		    GPNAME GREM GSWI GTEMP GTEMP1 GTEMP10 GTEMP11 GTEMP117 GTEMP118 GTEMP119 GTEMP12 GTEMP120 GTEMP127 
		    GTEMP13 GTEMP14 GTEMP15 GTEMP16 GTEMP17 GTEMP18 GTEMP19 GTEMP2 GTEMP20 GTEMP21 GTEMP210 GTEMP212 
		    GTEMP213 GTEMP214 GTEMP215 GTEMP216 GTEMP217 GTEMP218 GTEMP219 GTEMP22 GTEMP220 GTEMP221 GTEMP222 
		    GTEMP223 GTEMP224 GTEMP23 GTEMP24 GTEMP25 GTEMP26 GTEMP27 GTEMP28 GTEMP29 GTEMP3 GTEMP30 GTEMP31 
		    GTEMP36 GTEMP37 GTEMP39 GTEMP4 GTEMP43 GTEMP44 GTEMP48 GTEMP5 GTEMP6 GTEMP7 GTEMP8 GTEMP9 GXTR-PART 
		    HCON ILEV INIT-CANDS INIT-DOTHRESH INIT-EXTHRESH INIT-INT-THRESH INIT-INTHRESH INIT-ONCE-LIST 
		    INIT-PAST GINTPREDS INT-THRESH INTHRESH JTRASH NCONCEPTS NEW-C-PARTS NEW-CANDS NEW-CONCEPTS 
		    NEW-ILEV NEW-PARTS NEWB NOSWAP-CONCEPTS OBJX ONCE-LIST OR-PARTS ORIG-EMP PAST PHIST PKNT PMAC PREC 
		    RANC RANDSTATE RANF RANU RB1 RTEM2 STICKY-B STICKY-P STRAT STRATEGY-PARTS SUF-PARTS SUF1 SUF2 SWSUF 
		    SYS-FORGET-LIST TKNT-INIT TMP1 TMP2 TMP3 TMP4 TMP5 TMP6 TMP7 TMP8 TMP9 TOP-ACTS TOP4COMS TRIV-B 
		    TRIVB USERNAMES UTIL4COMS VCONCEPTS VERBOSITY VERSION XEQ-PARTS XS-PARTS))
  (RPAQQ REPR-FNS
	 (ACCEPT-B APPLYB BPFS CHANGE-B CREATEB DECRB DEFB DEFP DWIMUSERFN GCB GETB GETBQ GETU GLUE GLUEE INCRB 
		   INIT-PART PGET PSUF PUTB PUTU PXEQ SETB SETBQ SWAPB SWGETB SWSETB))
  (RPAQQ SAVECOMS (GLOBALVARS (VARS * GLOBALVARS)))
  (RPAQQ STICKY-B ACTIVE-EXS)
  (RPAQQ STICKY-P FILLIN1)
  (RPAQQ SYS-FORGET-LIST (DISPLAYTERMP PRETTYCOMPRINT PACK-IN-COMPBLOCK MAKESYS OBIN FGETP OSIN SYSOUT OSFBSZ PUTDQ 
				       /SETPROPLIST SETTOPVAL /SETTOPVAL SETPROPLIST SETFILEPTR EDITV EDITF DEFINEQ))
  (RPAQQ UCASELST
	 (CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER INIT-CANDS INIT-ONCE-LIST 
		    INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INTHRESH INTHRESH JTRASH RANDSTATE TOP-ACTS TRIVB 
		    USERNAMES VERBOSITY CONCEPTS FACETS AUX-FACETS SUF-PARTS XEQ-PARTS XS-PARTS))
  (RPAQQ VERSION 4)
  (ADDTOVAR USERMACROS (COPY (N)
			     (INSERT (## N)
				     AFTER N))
	    (C NIL (MBD * *)))
  (ADDTOVAR EDITCOMSA C)
  (ADDTOVAR EDITCOMSL COPY)
  (INIT-MAC)
  (SETQ FIXEDCONS NIL)
  (SETQ FIXVARS NIL)
  (SETQ FIXFNS NIL)
  [ADVISE (QUOTE EDITV)
	  (QUOTE (SETQ FIXVARS (UNION EDITVX FIXVARS]
  [ADVISE (QUOTE EDITF)
	  (QUOTE (SETQ FIXFNS (UNION EDITFX FIXFNS]
  [ADVISE (QUOTE DEFINEQ)
	  (QUOTE (SETQ FIXFNS (UNION (LIST (CAAR X))
				     FIXFNS]
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
  (ADDTOVAR NLAMA)
  (ADDTOVAR NLAML MTOP MAPP MAPB)
]
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1165 15616 (ACCEPT-B 1177 . 1795) (AM-BT 1799 . 2219) (CHANGE-B 2223 . 2934) (CLEAN 2938 . 3230) (CLEAN1
3234 . 3357) (CLEANALL 3361 . 3514) (CONDENSEB 3518 . 4035) (ED-1F 4039 . 4154) (ED-1P 4158 . 4285) (ED-1V 4289 .
4537) (ED-ALL 4541 . 4636) (ED-ALLF 4640 . 4917) (ED-ALLP 4921 . 4979) (ED-ALLV 4983 . 5180) (FORGOT-ANY 5184 . 6081)
(GLOB 6085 . 6355) (INIT-MAC 6359 . 8588) (INIT2 8592 . 8684) (KILLB 8688 . 9000) (LISTF 9004 . 9131) (LISTFILES1
9135 . 9680) (MAPB 9684 . 9777) (MAPP 9781 . 9882) (MCON 9886 . 10016) (MFIX 10020 . 10223) (MTOP 10227 . 10386) (
NEW-VERSION 10390 . 10829) (NFACET 10833 . 11637) (NFUN 11641 . 11991) (RESET1 11995 . 12302) (RESET2 12306 . 12444)
(RESET3 12448 . 13559) (RESTORE-EXPR 13563 . 13633) (SAVE 13637 . 13686) (SHOWP 13690 . 13909) (SUPERTRACE 13913 .
14447) (TRANFUN 14451 . 15107) (UPCASE 15111 . 15228) (XEQ-CLEAN 15232 . 15613)))))
STOP